;;; cpan.el --- This elisp program is major mode for cpan.

;; Copyright (C) 2007 <perlnamehoge@gmail.com>

;; Author: Daisuke_Abui <perlnamehoge@gmail.com>
;; Keywords: cpan, perl, search

;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Install:
;;   1, Put this emacs-extend-file to a directory in load-path. 
;;   2, Add the following line to your ~/.emacs.
;;      (require 'cpan)
;;   3, "cpan-search-module(function)" bind key to your favorite command.
;;      Example: (global-set-key "\C-xcp" 'cpan-search-module)

;;; Code:

(defface cpan-menu-heading
  '((t (:inherit font-lock-type-face)))
  "Face used to highlight the heading in cpan menu buffers."
  :group 'cpan-list
  :version "22.1")

(defvar cpan-menu-mode-map nil)
(defvar cpan-module-list nil)
(defvar cpan-module-current-list nil)
(defvar cpan-installed-module-list nil)
(defvar cpan-client-counter 0)
(defvar cpan-client-buf-name nil)
(defvar cpan-module-list-etag nil)
(defvar cpan-module-list-file ".cpandetails")
(defvar cpan-search-current-counter 1)
(defvar cpan-search-current-faces '((:background "LemonChiffon" "yellow")
                                    (:background "DarkSeaGreen1" "PaleGreen1" "green")
                                    (:background "NavajoWhite1" "orange")
                                    (:background "CornflowerBlue" "blue")))

(if cpan-menu-mode-map
    nil
  (setq cpan-menu-mode-map (make-keymap))
  (suppress-keymap cpan-menu-mode-map t)
  (define-key cpan-menu-mode-map "n" 'cpan-forward-line)
  (define-key cpan-menu-mode-map "p" 'cpan-backward-line)
  (define-key cpan-menu-mode-map "s" 'cpan-search-module)
  (define-key cpan-menu-mode-map "r" 'cpan-search-current-module)
  (define-key cpan-menu-mode-map "w" 'cpan-copy-current-line-module-name)
  ;; (define-key cpan-menu-mode-map "g" 'cpan-module-show-all)
  (define-key cpan-menu-mode-map "l" 'cpan-installed-module-show)
  (define-key cpan-menu-mode-map "u" 'cpan-module-list-update-check)
  (define-key cpan-menu-mode-map "\C-m" 'cpan-view-perldoc)
  (define-key cpan-menu-mode-map "i" 'cpan-module-install)
  (define-key cpan-menu-mode-map "v" 'cpan-view-source))

(defun cpan-menu-mode ()
  (kill-all-local-variables)
  (use-local-map cpan-menu-mode-map)
  (setq major-mode 'cpan-menu-mode
        mode-name "Cpan"
        buffer-read-only t
        undo-outer-limit 4000000))

(defun cpan-insert-header ( count )
  ""
  (insert (concat
           "% Cpan Module List --- "
           (format "%s" count)
           " module"
           (if (>= count 2) "s")
           " found.\n"))
  (insert (format "%-2s%-62s%s\n" "- " "Module-Name" "Version"))
  (add-text-properties (point-min) (point)
                       '(font-lock-face cpan-menu-heading)))

(defun cpan-expand-modules ( modules &optional keyword )
  ""
  (let ((installed-modules (cpan-get-installed-module-list))
        (module nil)
        (buf (switch-to-buffer (get-buffer-create "*cpan*")))
        (buffer-read-only nil))
    (erase-buffer)
    (cpan-insert-header (length modules))
    (while modules
      (setq module (car modules))
      (insert (if (assoc (format "%s" (car module)) installed-modules)
                  "i "
                "  "))
      (add-text-properties (- (point) 2) (point)
                           '(font-lock-face cpan-menu-heading))
      (insert (format "%-62s%s\n" (car module) (car (cdr module))))
      (setq modules (cdr modules)))
    (goto-char (point-min))
    (forward-line 2)
    (and
     keyword
     (save-excursion
       (while (re-search-forward keyword nil t)
         (add-text-properties
          (match-beginning 0)
          (match-end 0) '(font-lock-face (:background "LemonChiffon" "yellow"))))))
    (cpan-menu-mode)))

(defun cpan-module-show-all ()
  ""
  ;; (interactive)
  (let ((modules (cpan-module-list-get)))
    (cpan-expand-modules modules)))

(defun cpan-installed-module-show ()
  ""
  (interactive)
  (cpan-expand-modules
   (mapcar (function (lambda (module) (car (cdr module))))
           (cpan-get-installed-module-list))))

(defun cpan-search-module ( &optional current-modules module )
  ""
  (interactive)
  (let* ((completion-ignore-case t)
         (modules (if current-modules
                      current-modules
                    (cpan-module-list-get)))
         (module-name (or
                       module
                       (completing-read "Module-Name (From All): " modules))))
    (setq cpan-search-current-counter 1)
    (if (>= (length module-name) 2)
        (cpan-expand-modules
         (setq cpan-module-current-list (delete nil (mapcar (function (lambda (module)
                                                                        (if (string-match module-name (format "%s" (car module)))
                                                                            module
                                                                          nil)))
                                                            modules))) module-name)
      (error "require 2 charactor."))))

(defun cpan-search-current-module ()
  ""
  (interactive)
  (if (and
       cpan-module-current-list
       (not (get-buffer "*cpan*")))
      (cpan-search-module)
    (let* ((buf (switch-to-buffer (get-buffer "*cpan*")))
          (buffer-read-only nil)
          (completion-ignore-case t)
          (module-name
           (completing-read "Module-Name (From Current): " cpan-module-current-list))
          (pos) (target-module) (cpan-module-temp-current-list)
          (counter (if (>= (length module-name) 2)
                  0
                (error "require 2 charactor."))))
      (goto-line (point-min))
      (save-excursion
        (goto-line 3)
        (while (and
                (not (eobp))
                (setq pos (point))
                (not (forward-char 2))
                (re-search-forward "[^ ]+" nil t)
                (setq target-module (buffer-substring
                              (match-beginning 0)
                              (match-end 0))))
          (if (string-match module-name target-module)
              (progn
                (setq cpan-module-temp-current-list (cons target-module cpan-module-temp-current-list)
                      counter (1+ counter))
                (if (re-search-backward module-name nil t)
                    (add-text-properties (match-beginning 0)
                                         (match-end 0)
                                         (list 'font-lock-face (nth cpan-search-current-counter cpan-search-current-faces))))
                (forward-line 1))
            (delete-region pos (progn
                                 (forward-line 1)
                                 (point))))))
      (progn
        (delete-region
         (point)
         (progn
           (goto-line 3)
           (point)))
        (cpan-insert-header counter))
      (setq cpan-module-current-list cpan-module-temp-current-list
            cpan-search-current-counter (1+ cpan-search-current-counter)))))

(defun cpan-check-position ()
  ""
  (cond ((< (count-lines (point-min) (point)) 2)
         (goto-char (point-min))
         (forward-line 2)
         t)
        (t
         (beginning-of-line)
         t)))

(defun cpan-get-installed-module-list ()
  ""
  (if cpan-installed-module-list
      cpan-installed-module-list
    (let* ((nickname "*perllocal*")
           (modules)
           (module-name)
           (version))
      (call-process "perldoc" nil (set-buffer (get-buffer-create nickname)) nil "perllocal")
      (goto-char (point-min))
      (while (re-search-forward "\"Module\" " nil t)
        (setq module-name (buffer-substring
                           (point)
                           (progn
                             (end-of-line)
                             (point)))
              version (progn
                        (re-search-forward "VERSION: \\(.*[^\"]\\)\"" nil t)
                        (buffer-substring
                         (match-beginning 1)
                         (match-end 1))))
        (setq modules
              (cons (list module-name (list module-name version)) modules)))
      (kill-buffer (current-buffer))
      (setq cpan-installed-module-list modules))))

(defun cpan-module-list-get ()
  ""
  (if cpan-module-list
      cpan-module-list
    (if (file-exists-p (expand-file-name cpan-module-list-file "~/"))
        (progn
          (set-buffer (get-buffer-create "*cpan-module-list*"))
          (insert-file-contents (expand-file-name cpan-module-list-file "~/"))
          (setq cpan-module-list (read (current-buffer)))
          (kill-buffer (current-buffer))
          (if (listp cpan-module-list)
              cpan-module-list
            (error "Can't read list file because it's invalid data format.")))
      (if (yes-or-no-p "Can't read list file because it's not exist. Download now ? ")
          (progn
            (cpan-module-list-get-client-start)
            (error ""))
        (error "")))))

(defun cpan-module-list-get-client-start ()
  "get file from http server"
  (let ((proc nil))
    (setq cpan-client-buf-name (get-buffer-create "*web client*")
          cpan-module-list-etag nil)
    (progn
      (defun filter (proc in)
          (if (string-match "\\(^ETag: \".*[^\"]\"\\)" in)
              (progn
                (setq cpan-module-list-etag (substring in (match-beginning  1) (match-end 1)))
                (message "%s" "Download status: ")))
          (setq cpan-client-counter (1+ cpan-client-counter))
          (set-buffer cpan-client-buf-name)
          (insert in)
          (if (= 0 (% cpan-client-counter 30))
              (message "%s%s%s" "Download status: " (make-string (/ cpan-client-counter 30) ?=) ">")))
      (defun sentinel (proc out)
        (setq cpan-client-counter 0)
        (set-buffer cpan-client-buf-name)
        (goto-char (point-min))
        (re-search-forward "^File:" nil t)
        (re-search-forward "^\\W" nil t)
        (delete-region (point-min) (point))
        (insert (format ";; This file is cpan module archive file.\n;; %s\n" cpan-module-list-etag))
        (cpan-make-module-list))
      (setq proc (open-network-stream
                  "web-connection"
                  cpan-client-buf-name
                  "www.cpan.org"
                  80))
      (set-process-coding-system proc 'binary 'binary)
      (process-send-string
       proc
       (format (concat
                "GET /modules/02packages.details.txt HTTP/1.0\r\n"
                "MIME-Version: 1.0\r\n"
                "\r\n")))
      (set-process-filter proc 'filter)
      (set-process-sentinel proc 'sentinel))))

(defun cpan-make-module-list ()
  ""
  (let ((buf (current-buffer))
        (counter 1))
    (insert "(")
    (while (not (eobp))
      (insert "(")
      (end-of-line)
      (insert ")")
      (setq counter (1+ counter))
      (forward-line 1)
      (if (= 0 (% counter 1000))
          (message "please wait while make index %s" (make-string (/ counter 1000) ?.))))
    (insert ")")
    (condition-case nil
        (write-region (point-min) (point-max) (expand-file-name cpan-module-list-file "~/"))
      (file-error "Can't write %s" (expand-file-name cpan-module-list-file "~/")))
    (kill-buffer buf)
    (setq cpan-module-list nil
          cpan-module-current-list nil)
    (cpan-search-module)))

(defun cpan-module-list-update-check ()
  ""
  (interactive)
  (let ((etag (progn
                (set-buffer (find-file-noselect (expand-file-name cpan-module-list-file "~/")))
                (goto-char (point-min))
                (if (re-search-forward "ETag: \"\\([^\"]*\\)\"" nil t)
                    (prog1
                        (buffer-substring
                         (match-beginning 1) (match-end 1))
                      (kill-buffer (current-buffer)))
                  (error ""))))
        (buf (set-buffer (get-buffer-create "*cpandetails-header*")))
        (proc))
    (setq cpan-module-list-etag etag)
    (setq proc (open-network-stream
                "web-connection"
                buf
                "www.cpan.org"
                80))
    (process-send-string
     proc
     (format (concat
              "HEAD /modules/02packages.details.txt HTTP/1.0\r\n"
              "\r\n")))
    (set-process-filter proc (function (lambda (proc in)
                                         (if (not (string-match cpan-module-list-etag in))
                                             (if (y-or-n-p "Cpan module list is old. update now? ")
                                                 (cpan-module-list-get-client-start)
                                               (message "%s" "stop update."))
                                           (message "%s" "no update.")))))
    (set-process-sentinel proc (function (lambda (proc out)
                                           (kill-buffer "*cpandetails-header*"))))))

(defun cpan-module-install ()
  ""
  (interactive)
  (let ((module (cpan-get-module-name)))
    (shell)
    (goto-char (point-max))
    (insert (format "%s%s" "sudo -H cpan " module))))

(defun cpan-view-perldoc ()
  ""
  (interactive)
  (let ((module (cpan-get-module-name))
        (buffer (get-buffer-create "*perldoc*")))
    (shell-command (concat "perldoc " module) buffer)
    (set-buffer buffer)
    (goto-char (point-min))
    (if (string-match "No documentation found" (buffer-substring (point-min) (point-max)))
        (progn
          (message "%s" (buffer-substring (point-min) (progn
                                                        (end-of-line)
                                                        (point))))
          (kill-buffer buffer))
      (switch-to-buffer buffer)
      (delete-other-windows)
)))

(defun cpan-copy-current-line-module-name ()
  ""
  (interactive)
  (let ((module (cpan-get-module-name)))
    (if (eq last-command 'cpan-copy-current-line-module-name)
            (kill-append module nil)
            (kill-new module))
    (message "%s" module)))

(defun cpan-get-module-name ()
  ""
  (interactive)
  (let ()
    (if (cpan-check-position)
        (progn
          (save-excursion
            (forward-char 2)
            (re-search-forward "\\(.*?\\) +" nil t))
          (message "%s" (buffer-substring (match-beginning 1) (match-end 1)))))))

(defun cpan-forward-line ()
  ""
  (interactive)
  (forward-line 1))

(defun cpan-backward-line ()
  ""
  (interactive)
  (forward-line -1))

(defun cpan-open-the-cpan-module (module)
  ""
  (interactive "sType the perl module : ")
  (let ((output
         (substring (shell-command-to-string (concat "perldoc -ml " module)) 0 -1)))
    (unless (and
             (and
              (string-match "No module" output)
              (message "%s" output))
             (not (file-exists-p output)))
      (find-file-read-only output))))

(defun cpan-view-source ()
  ""
  (interactive)
  (let ((module (cpan-get-module-name)))
    (cpan-open-the-cpan-module module)))

(provide 'cpan)

;;; cpan.el ends here
